home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / SUBS3.PAS < prev    next >
Pascal/Delphi Source File  |  1991-02-15  |  23KB  |  819 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit subs3;
  5.  
  6. interface
  7.  
  8. uses crt,dos,mycomman,
  9.      gentypes,configrt,statret,gensubs,subs1,windows,subs2,modem,
  10.      protocol;
  11.  
  12. const local_file_header_signature = $04034b50;
  13.       central_file_header_signature = $02014b50;
  14.       end_central_dir_signature = $06054b50;
  15.       compression_methods: array[0..6] of string[8]=
  16.       (' Stored ',' Shrunk ','Reduce-1','Reduce-2','Reduce-3','Reduce-4','?');
  17.       uinbufsize=512;
  18.       hsize=8192;
  19.  
  20. type
  21.    signature_type = longint;
  22.  
  23.    local_file_header = record
  24.       version_needed_to_extract:    word;
  25.       general_purpose_bit_flag:     word;
  26.       compression_method:           word;
  27.       last_mod_file_time:           word;
  28.       last_mod_file_date:           word;
  29.       crc32:                        longint;
  30.       compressed_size:              longint;
  31.       uncompressed_size:            longint;
  32.       filename_length:              word;
  33.       extra_field_length:           word;
  34.    end;
  35.  
  36.    central_directory_file_header = record
  37.       version_made_by:                 word;
  38.       version_needed_to_extract:       word;
  39.       general_purpose_bit_flag:        word;
  40.       compression_method:              word;
  41.       last_mod_file_time:              word;
  42.       last_mod_file_date:              word;
  43.       crc32:                           longint;
  44.       compressed_size:                 longint;
  45.       uncompressed_size:               longint;
  46.       filename_length:                 word;
  47.       extra_field_length:              word;
  48.       file_comment_length:             word;
  49.       disk_number_start:               word;
  50.       internal_file_attributes:        word;
  51.       external_file_attributes:        longint;
  52.       relative_offset_local_header:    longint;
  53.    end;
  54.  
  55.    end_central_dir_record = record
  56.       number_this_disk:                         word;
  57.       number_disk_with_start_central_directory: word;
  58.       total_entries_central_dir_on_this_disk:   word;
  59.       total_entries_central_dir:                word;
  60.       size_central_directory:                   longint;
  61.       offset_start_central_directory:           longint;
  62.       zipfile_comment_length:                   word;
  63.    end;
  64.  
  65.    central_list_ptr = ^central_list;
  66.    central_list = record
  67.       dir:     central_directory_file_header;
  68.       name:    string;
  69.       extra:   string;
  70.       comment: string;
  71.       next:    central_list_ptr;
  72.    end;
  73.  
  74.    string8=string[8];
  75.  
  76.    sarray = array[0..255] of string[64];
  77.  
  78.    hsize_array_integer = array[0..hsize] of integer;
  79.    hsize_array_byte    = array[0..hsize] of byte;
  80.  
  81. var
  82.    zipfd:   dos_handle;
  83.    zipfn:   dos_filename;
  84.    efn:     dos_filename;
  85.    dir:     anystr;
  86.    var
  87.    zipname:       dos_filename;
  88.    scratchzip:    dos_filename;
  89.    pattern:       dos_filename;
  90.    extcount:      integer;
  91.    xrec:          central_directory_file_header;
  92.    rec:           local_file_header;
  93.    ofd:           dos_handle;
  94.    sig:           signature_type;
  95.    cdir:          central_list_ptr;
  96.    lcdir:         central_list_ptr;
  97.    endrec:        end_central_dir_record;
  98.    filename:      string;
  99.    extra:         string;
  100.    dups:          boolean;
  101.    zipeof:      boolean;
  102.    csize:       longint;
  103.    cusize:      longint;
  104.    cmethod:     integer;
  105.    ctime:       word;
  106.    cdate:       word;
  107.    inbuf:       array[1..uinbufsize] of byte;
  108.    inpos:       integer;
  109.    incnt:       integer;
  110.    pc:          byte;
  111.    pcbits:      byte;
  112.    pcbitv:      byte;
  113.    outbuf:      array[0..4096] of byte; {for rle look-back}
  114.    outpos:      longint;                {absolute position in outfile}
  115.    outcnt:      integer;
  116.    outfd:       dos_handle;
  117.    factor:      integer;
  118.    followers:   sarray;
  119.    exstate:     integer;
  120.    c:           integer;
  121.    v:           integer;
  122.    len:         integer;
  123.    prefix_of:   hsize_array_integer;
  124.    suffix_of:   hsize_array_byte;
  125.    stack:       hsize_array_byte;
  126.    stackp:      integer;
  127.  
  128. function getextdesc:string;
  129. function wildcardmatch (w,f:sstr):boolean;
  130. procedure get_string (len:word; var s:string);
  131. procedure itoa2 (i:integer; var sp);
  132. function format_date (date:word):string8;
  133. function format_time (time:word):string8;
  134. procedure process_local_file_header;
  135. procedure process_central_file_header;
  136. procedure process_end_central_dir;
  137. procedure process_headers;
  138. procedure listzip (name:dos_filename);
  139. procedure arcview (fname:lstr);
  140. procedure pakview (filename:lstr);
  141. procedure lharcview (filename:lstr);
  142. procedure zipview (fn:lstr);
  143. procedure extractzip (ffile,mainzip,todir:anystr);
  144. procedure extractarc (ffile,mainzip,todir:anystr);
  145. procedure extractpak (ffile,mainzip,todir:anystr);
  146. procedure extractlzh (ffile,mainzip,todir:anystr);
  147. procedure extract (ffile,mainzip,todir:anystr);
  148. procedure addtozip (zipname,fn:anystr);
  149. procedure addcomment (path:anystr; filename:sstr);
  150. function getpath (dir:anystr):lstr;
  151. procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
  152. procedure writefreespace (path:lstr);
  153. function allowxfer:boolean;
  154. procedure fileinfo (yiyiyi:integer);
  155.  
  156. implementation
  157.  
  158. function getextdesc:string;
  159.   var nappa:string[255];
  160.       a,b,c:string;
  161.       extdone:boolean;
  162.       finalcut:integer;
  163.   begin
  164.    getextdesc:='';
  165.    nappa:='';
  166.    extdone:=false;
  167.    finalcut:=0;
  168.    writeln (^P'Extended Description 3 Lines Max - Hit [CR] to end (Wordwrap Active)'^R);
  169.    writeln (^P'[--------|---------|---------|---------|---------|---------|---------|--------]'^R);
  170.    repeat
  171.     buflen:=80;
  172.     wordwrap:=true;
  173.     getstr (1);
  174.     finalcut:=finalcut+1;
  175.     if finalcut>2 then extdone:=true;
  176.     if length(input)<1 then extdone:=true else
  177.     nappa:=nappa+input;
  178.    until extdone;
  179.    wordwrap:=false;
  180.    getextdesc:=nappa;
  181.   end;
  182.  
  183.  
  184. (* ---------------------------------------------------------- *)
  185.  
  186. function wildcardmatch (w,f:sstr):boolean;
  187. var a,b:sstr;
  188.  
  189.     procedure transform (t:sstr; var q:sstr);
  190.     var p:integer;
  191.  
  192.       procedure filluntil (k:char; n:integer);
  193.       begin
  194.         while length(q)<n do q:=q+k
  195.       end;
  196.  
  197.       procedure dopart (mx:integer);
  198.       var k:char;
  199.       begin
  200.         repeat
  201.           if p>length(t)
  202.             then k:='.'
  203.             else k:=t[p];
  204.           p:=p+1;
  205.           case k of
  206.             '.':begin
  207.                   filluntil (' ',mx);
  208.                   exit
  209.                 end;
  210.             '*':filluntil ('?',mx);
  211.             else if length(q)<mx then q:=q+k
  212.           end
  213.         until 0=1
  214.       end;
  215.  
  216.     begin
  217.       p:=1;
  218.       q:='';
  219.       dopart (8);
  220.       dopart (11)
  221.     end;
  222.  
  223.     function theymatch:boolean;
  224.     var cnt:integer;
  225.     begin
  226.       theymatch:=false;
  227.       for cnt:=1 to 11 do
  228.         if (a[cnt]<>'?') and (b[cnt]<>'?') and
  229.            (upcase(a[cnt])<>upcase(b[cnt])) then exit;
  230.       theymatch:=true
  231.     end;
  232.  
  233.   begin
  234.     transform (w,a);
  235.     transform (f,b);
  236.     wildcardmatch:=theymatch
  237.   end;
  238.  
  239. (* ---------------------------------------------------------- *)
  240.  
  241. (* ---------------------------------------------------------- *)
  242. procedure get_string(len: word; var s: string);
  243. var
  244.    n: word;
  245. begin
  246.    if len > 255 then
  247.       len := 255;
  248.    n := dos_read(zipfd,s[1],len);
  249.    s[0] := chr(len);
  250. end;
  251.  
  252. (* ---------------------------------------------------------- *)
  253. procedure itoa2(i: integer; var sp);
  254. var
  255.    s: array[1..2] of char absolute sp;
  256. begin
  257.    s[1] := chr( (i div 10) + ord('0'));
  258.    s[2] := chr( (i mod 10) + ord('0'));
  259. end;
  260.  
  261. function format_date(date: word): string8;
  262. const
  263.    s:       string8 = 'mm-dd-yy';
  264. begin
  265.    itoa2(((date shr 9) and 127)+80, s[7]);
  266.    itoa2( (date shr 5) and 15,  s[1]);
  267.    itoa2( (date      ) and 31,  s[4]);
  268.    format_date := s;
  269. end;
  270.  
  271. function format_time(time: word): string8;
  272. const
  273.    s:       string8 = 'hh:mm:ss';
  274. begin
  275.    itoa2( (time shr 11) and 31, s[1]);
  276.    itoa2( (time shr  5) and 63, s[4]);
  277.    itoa2( (time shl  1) and 63, s[7]);
  278.    format_time := s;
  279. end;
  280.  
  281. (* ---------------------------------------------------------- *)
  282. procedure process_local_file_header;
  283. var
  284.    n:             word;
  285.    rec:           local_file_header;
  286.    filename:      string;
  287.    extra:         string;
  288.  
  289. begin
  290.    n := dos_read(zipfd,rec,sizeof(rec));
  291.    get_string(rec.filename_length,filename);
  292.    get_string(rec.extra_field_length,extra);
  293.    dos_lseek(zipfd,rec.compressed_size,seek_cur);
  294. end;
  295.  
  296. (* ---------------------------------------------------------- *)
  297. procedure process_central_file_header;
  298. var
  299.    n:             word;
  300.    rec:           central_directory_file_header;
  301.    filename:      string;
  302.    extra:         string;
  303.    comment:       string;
  304.  
  305. begin
  306.    n := dos_read(zipfd,rec,sizeof(rec));
  307.    get_string(rec.filename_length,filename);
  308.    get_string(rec.extra_field_length,extra);
  309.    get_string(rec.file_comment_length,comment);
  310.  
  311.    write(rec.uncompressed_size:7,'  ',
  312.            compression_methods[rec.compression_method]:8,' ',
  313.            rec.compressed_size:7,'   ',
  314.            format_date(rec.last_mod_file_date),'  ',
  315.            format_time(rec.last_mod_file_time));
  316.  
  317.    if (rec.internal_file_attributes and 1) <> 0 then
  318.       write('   Ascii  ')
  319.    else
  320.       write('  Binary  ');
  321.  
  322.    writeln(filename);
  323.  
  324. (**************
  325.    writeln;
  326.    writeln('central file header');
  327.    writeln('   filename = ',filename);
  328.    writeln('   extra = ',extra);
  329.    writeln('   file comment = ',comment);
  330.    writeln('   version_made_by = ',rec.version_made_by);
  331.    writeln('   version_needed_to_extract = ',rec.version_needed_to_extract);
  332.    writeln('   general_purpose_bit_flag = ',rec.general_purpose_bit_flag);
  333.    writeln('   compression_method = ',rec.compression_method);
  334.    writeln('   last_mod_file_time = ',rec.last_mod_file_time);
  335.    writeln('   last_mod_file_date = ',rec.last_mod_file_date);
  336.    writeln('   crc32 = ',rec.crc32);
  337.    writeln('   compressed_size = ',rec.compressed_size);
  338.    writeln('   uncompressed_size = ',rec.uncompressed_size);
  339.    writeln('   disk_number_start = ',rec.disk_number_start);
  340.    writeln('   internal_file_attributes = ',rec.internal_file_attributes);
  341.    writeln('   external_file_attributes = ',rec.external_file_attributes);
  342.    writeln('   relative_offset_local_header = ',rec.relative_offset_local_header);
  343. ***********)
  344.  
  345. end;
  346.  
  347.  
  348. (* ---------------------------------------------------------- *)
  349. procedure process_end_central_dir;
  350. var
  351.    n:             word;
  352.    rec:           end_central_dir_record;
  353.    comment:       string;
  354.  
  355. begin
  356.    n := dos_read(zipfd,rec,sizeof(rec));
  357.    get_string(rec.zipfile_comment_length,comment);
  358.  
  359. (*******
  360.    writeln;
  361.    writeln('end central dir');
  362.    writeln('   zipfile comment = ',comment);
  363.    writeln('   number_this_disk = ',rec.number_this_disk);
  364.    writeln('   number_disk_with_start_central_directory = ',rec.number_disk_with_start_central_directory);
  365.    writeln('   total_entries_central_dir_on_this_disk = ',rec.total_entries_central_dir_on_this_disk);
  366.    writeln('   total_entries_central_dir = ',rec.total_entries_central_dir);
  367.    writeln('   size_central_directory = ',rec.size_central_directory);
  368.    writeln('   offset_start_central_directory = ',rec.offset_start_central_directory);
  369. ********)
  370.  
  371. end;
  372.  
  373. (* ---------------------------------------------------------- *)
  374. procedure process_headers;
  375. var
  376.    sig:  longint;
  377.    fail: integer;
  378.  
  379. begin
  380.    fail := 0;
  381.  
  382.    while true do
  383.    begin
  384.  
  385.       if dos_read(zipfd,sig,sizeof(sig)) <> sizeof(sig) then
  386.          exit
  387.       else
  388.  
  389.       if sig = local_file_header_signature then
  390.          process_local_file_header
  391.       else
  392.  
  393.       if sig = central_file_header_signature then
  394.          process_central_file_header
  395.       else
  396.  
  397.       if sig = end_central_dir_signature then
  398.       begin
  399.          process_end_central_dir;
  400.          exit;
  401.       end
  402.       else
  403.  
  404.       begin
  405.          inc(fail);
  406.          if fail > 100 then
  407.          begin
  408.             writeln('Invalid Zipfile Header!');
  409.             exit;
  410.          end;
  411.       end;
  412.    end;
  413. end;
  414.  
  415. (* ---------------------------------------------------------- *)
  416. procedure listzip(name: dos_filename);
  417. begin
  418.    zipfd := dos_open(name,open_read);
  419.    if zipfd = dos_error then
  420.    begin
  421.       writeln('Can''t open: ',name);
  422.       exit;
  423.    end;
  424.    writeln;
  425.    if (pos('?',zipfn)+pos('*',zipfn)) > 0 then
  426.    begin
  427.       writeln('Zipfile: '+name);
  428.       writeln;
  429.    end;
  430.    writeln('  Size    Method   Zipped     Date      Time     Type     File Name');
  431.    if (asciigraphics in urec.config) then
  432.    writeln('──────── ──────── ────────  ────────  ────────  ──────  ─────────────')
  433.    else
  434.    writeln('-------- -------- --------  --------  --------  ------  -------------');
  435.    process_headers;
  436.    dos_close(zipfd);
  437. end;
  438.  
  439. (* ---------------------------------------------------------- *)
  440.  
  441. procedure arcview (fname:lstr);
  442. var f:file of byte;
  443.     b:byte;
  444.     sg:boolean;
  445.     size:longint;
  446.     n:integer;
  447.  
  448. function getsize:longint;
  449. var x:longint;
  450.     b:array [1..4] of byte absolute x;
  451.     cnt:integer;
  452. begin
  453.  for cnt:=1 to 4 do read (f,b[cnt]);
  454.  getsize:=x
  455. end;
  456.  
  457. begin
  458.  assign (f,fname);
  459.  reset (f);
  460.  iocode:=ioresult;
  461.  if iocode<>0 then begin
  462.   fileerror ('LISTARCHIVE',fname);
  463.   exit;
  464.  end;
  465.  if (filesize(f)<32) then begin
  466.   writeln (^M'That file isn''t an archive!');
  467.   close (f);
  468.   exit;
  469.  end;
  470.  writeln ('Filename        Size');
  471.  if (asciigraphics in urec.config) then
  472.  writeln ('────────────    ────') else
  473.  writeln ('------------    ----');
  474.  repeat
  475.   read (f,b);
  476.   if b<>26 then begin
  477.    writeln (^M'That file isn''t an archive!');
  478.    close (f);
  479.    exit
  480.   end;
  481.   read (f,b);
  482.   if b=0 then begin
  483.    close (f);
  484.    exit
  485.   end;
  486.   sg:=false;
  487.   for n:=1 to 13 do begin
  488.    read (f,b);
  489.    if b=0 then sg:=true;
  490.    if sg then b:=32;
  491.    write (chr(b))
  492.   end;
  493.   size:=getsize;
  494.   for n:=1 to 6 do read (f,b);
  495.   writeln ('   ',getsize);
  496.   seek (f,filepos(f)+size)
  497.  until break or hungupon;
  498. end;
  499.  
  500. procedure pakview (filename:lstr);
  501. var f:file of byte;
  502. begin
  503.  if not exist (pak) then begin
  504.   writeln (^M'Error: '+pak+' not found. Notify Sysop.'^M);
  505.   exit;
  506.  end;
  507.  exec (GetEnv('COMSPEC'),'/C '+pak+' v '+filename+' >PAK.LST');
  508.  printfile ('PAK.LST')
  509. end;
  510.  
  511. procedure lharcview (filename:lstr);
  512. var f:file of byte;
  513. begin
  514.  if not exist (lharc) then begin
  515.   writeln (^M'Error: '+lharc+' not found. Notify Sysop.'^M);
  516.   exit;
  517.  end;
  518.  exec (GetEnv('COMSPEC'),'/C '+lharc+' v '+filename+' >LHARC.LST');
  519.  printfile ('LHARC.LST')
  520. end;
  521.  
  522. procedure zipview (fn:lstr);
  523. var f:file of byte;
  524.     dirinfo:searchrec;
  525.     dir,nam,ext:dos_filename;
  526. begin
  527.  assign (f,fn);
  528.  reset (f);
  529.  iocode:=ioresult;
  530.  if iocode<>0 then begin
  531.   fileerror ('LISTARCHIVE',fn);
  532.   exit;
  533.  end;
  534.  if (filesize(f)<32) then begin
  535.   writeln (^M'That file isn''t an archive!');
  536.   close (f);
  537.   exit;
  538.  end;
  539.  close (f);
  540.  zipfn:=fn;
  541.  if pos('.',zipfn)=0 then zipfn:=zipfn+'.ZIP';
  542.  fsplit(zipfn,dir,nam,ext);
  543.  findfirst(zipfn,$21,dirinfo);
  544.  while (doserror=0) do
  545.  begin
  546.   listzip (dir+dirinfo.name);
  547.   findnext (dirinfo);
  548.  end;
  549. end;
  550.  
  551. procedure extractzip (ffile,mainzip,todir:anystr);
  552. var f:file of byte;
  553. begin
  554.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  555.  if not exist (faqdir+'PKUNZIP.EXE') then begin
  556.   writeln (^M'Error: PKUNZIP.EXE not found [supposed to be in '+faqdir+'].');
  557.   writeln ('Please notify Sysop!!');
  558.   exit;
  559.  end;
  560.  exec (GetEnv('COMSPEC'),'/C '+faqdir+'PKUNZIP.EXE '+mainzip+' '+ffile+' '+todir+' >NUL');
  561. end;
  562.  
  563. procedure extractarc (ffile,mainzip,todir:anystr);
  564. var f1,f2,f3:anystr;
  565. begin
  566.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  567.  f1:=faqdir+'PKUNPAK.EXE';
  568.  f2:=faqdir+'PKXARC.EXE';
  569.  f3:=faqdir+'PKXARC.COM';
  570.  if ((not exist (f1)) and (not exist (f2)) and (not exist (f3))) then
  571.  begin
  572.   writeln (^M'Error: PKUNPAK.EXE, PKXARC.EXE, and PKXARC.COM not found!');
  573.   writeln ('There are supposed to be in '+faqdir+'.');
  574.   writeln ('Please notify Sysop!!');
  575.   exit;
  576.  end;
  577.  if exist (f1) then exec (GetEnv('COMSPEC'),'/C '+f1+' '+mainzip+' '+ffile+' '+todir) else
  578.  if exist (f2) then exec (GetEnv('COMSPEC'),'/C '+f2+' '+mainzip+' '+ffile+' '+todir) else
  579.  if exist (f3) then exec (GetEnv('COMSPEC'),'/C '+f3+' '+mainzip+' '+ffile+' '+todir);
  580. end;
  581.  
  582. procedure extractpak (ffile,mainzip,todir:anystr);
  583. begin
  584.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  585.  if not exist (pak) then begin
  586.   writeln (^M'Error: '+pak+' not found!');
  587.   writeln ('Please notify Sysop!!');
  588.   exit;
  589.  end;
  590.  exec (GetEnv('COMSPEC'),'/C '+pak+' '+mainzip+' '+ffile+' '+todir);
  591. end;
  592.  
  593. procedure extractlzh (ffile,mainzip,todir:anystr);
  594. var lh1,lh2:lstr;
  595. begin
  596.  lh1:=faqdir+'LHARC.EXE';
  597.  lh2:=faqdir+'LHARC.COM';
  598.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  599.  if (not exist (lh1)) and (not exist (lh2)) then begin
  600.   writeln (^M'Error: LHARC.EXE, and LHARC.COM not found!');
  601.   writeln ('There are supposed to be in '+faqdir+'.');
  602.   writeln ('Please notify Sysop!!');
  603.   exit;
  604.  end;
  605.  if exist (lh1) then exec (GetEnv('COMSPEC'),'/C '+lh1+' '+mainzip+' '+ffile+' '+todir) else
  606.  if exist (lh2) then exec (GetEnv('COMSPEC'),'/C '+lh2+' '+mainzip+' '+ffile+' '+todir);
  607. end;
  608.  
  609. procedure extract (ffile,mainzip,todir:anystr);
  610. var t:sstr;
  611.     x:integer;
  612. begin
  613.  x:=pos ('.',mainzip);
  614.  t:=copy (mainzip,x+1,3);
  615.  t:=upstring(t);
  616.  if t='ZIP' then extractzip (ffile,mainzip,todir) else
  617.  if t='ARC' then extractarc (ffile,mainzip,todir) else
  618.  if t='PAK' then extractpak (ffile,mainzip,todir) else
  619.  if t='LZH' then extractlzh (ffile,mainzip,todir);
  620. end;
  621.  
  622. procedure addtozip (zipname,fn:anystr);
  623. begin
  624.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  625.  if not exist (faqdir+'PKZIP.EXE') then begin
  626.   writeln (^M'Error: PKZIP.EXE not found [supposed to be in '+faqdir+'].');
  627.   writeln ('Please notify Sysop!!');
  628.   exit;
  629.  end;
  630.  exec (GetEnv('COMSPEC'),'/C '+faqdir+'PKZIP.EXE -ex '+zipname+' '+fn+' >NUL');
  631. end;
  632.  
  633. procedure addcomment (path:anystr; filename:sstr);
  634. var filename1:sstr;
  635. begin
  636.  if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  637.  filename1:=copy(filename,length(filename)-2,3);
  638.  if not exist (faqdir+'COMMENT.BAT') then begin
  639.   writeln (^M'Error: COMMENT.BAT not found [supposed to be in '+faqdir+'].');
  640.   writeln ('Please notify Sysop!!');
  641.   exit;
  642.  end;
  643.  exec (GetEnv('COMSPEC'),'/C '+faqdir+'COMMENT.BAT '+path+filename+' '+filename1);
  644. end;
  645.  
  646. function getpath (dir:anystr):lstr;
  647.   var q,r:integer;
  648.       f:file;
  649.       b,found:boolean;
  650.       p,s:lstr;
  651.       t:text;
  652.   begin
  653.     getpath:=dir;
  654.     if ulvl<sysoplevel then exit;
  655.     repeat
  656.       found:=false;
  657.       writestr ('Upload Path [CR/'+dir+']:');
  658.       if hungupon then exit;
  659.       if length(input)=0 then input:=dir;
  660.       p:=input;
  661.       if input[length(p)]<>'\' then p:=p+'\';
  662.       b:=true;
  663.       if exist (faqdir+'SECURITY.DIR') then begin
  664.        assign (t,faqdir+'SECURITY.DIR');
  665.        reset (t);
  666.        repeat
  667.         readln (t,s);
  668.         if s[length(s)]<>'\' then s:=s+'\';
  669.         if match(s,p) then begin
  670.          found:=true;
  671.          writeln;
  672.          writeln (^G'That Directory is protected by the Sysop!');
  673.          writeln;
  674.         end;
  675.        until eof(t) or (found);
  676.        textclose (t);
  677.        if found then exit;
  678.       end;
  679.       assign (f,p+'CON');
  680.       reset (f);
  681.       q:=ioresult;
  682.       close (f);
  683.       r:=ioresult;
  684.       if q<>0 then begin
  685.         writestr ('  Path doesn''t exist!  Create it [y/n]? *');
  686.         b:=yes;
  687.         if b then begin
  688.           mkdir (copy(p,1,length(p)-1));
  689.           q:=ioresult;
  690.           b:=q=0;
  691.           if b
  692.             then writestr ('Directory created')
  693.             else writestr ('Unable to create directory')
  694.         end
  695.       end
  696.     until b;
  697.     getpath:=p
  698.   end;
  699.  
  700.   procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
  701.   var p:integer;
  702.   begin
  703.     path:='';
  704.     repeat
  705.       p:=pos('\',fname);
  706.       if p<>0 then begin
  707.         path:=path+copy(fname,1,p);
  708.         fname:=copy(fname,p+1,255)
  709.       end
  710.     until p=0;
  711.     name:=fname
  712.   end;
  713.  
  714.   procedure writefreespace (path:lstr);
  715.  
  716.   function unsigned (i:integer):real;
  717.   begin
  718.     if i>=0
  719.       then unsigned:=i
  720.       else unsigned:=65536.0+i
  721.   end;
  722.  
  723.   var drive:byte;
  724.       r:registers;
  725.       csize,free,total:real;
  726.   begin
  727.     r.ah:=$36;
  728.     r.dl:=ord(upcase(path[1]))-64;
  729.     intr ($21,r);
  730.     if r.ax=-1 then begin
  731.       writeln ('Invalid Drive!');
  732.       exit
  733.     end;
  734.     csize:=unsigned(r.ax)*unsigned(r.cx);
  735.     free:=csize*unsigned(r.bx);
  736.     total:=csize*unsigned(r.dx);
  737.     free:=free/1024;
  738.     total:=total/1024;
  739.     write (free:0:0,'k ');
  740.     if free<125 then write ('(minimal!) ');
  741.     writeln ('out of ',total:0:0,'k')
  742.   end;
  743.  
  744.   function allowxfer:boolean;
  745.   var cnt:baudratetype;
  746.       k:char;
  747.   begin
  748.     allowxfer:=false;
  749.     for cnt:=firstbaud to lastbaud do
  750.       if baudrate=baudarray[cnt]
  751.         then if not (cnt in downloadrates)
  752.           then begin
  753.             writeln ('Sorry, File Transfer is not allowed at ',baudrate,' Baud!');
  754.             exit
  755.           end;
  756.     if parity then begin
  757.       writeln ('Please select NO Parity (N,8,1) and hit [Return]:');
  758.       parity:=false;
  759.       setparam (usecom,baudrate,parity);
  760.       repeat
  761.         k:=getchar;
  762.         if hungupon then exit
  763.       until k in [#13,#141];
  764.       if k=#141 then begin
  765.         parity:=true;
  766.         setparam (usecom,baudrate,parity);
  767.         writeln ('You did not turn off parity.  Transfer aborted.');
  768.         exit
  769.       end
  770.     end;
  771.     allowxfer:=true
  772.   end;
  773.  
  774.   procedure fileinfo (yiyiyi:integer);
  775.   var i:integer;
  776.       ud:udrec;
  777.       okay:boolean;
  778.       a,b,c:string;
  779.   begin
  780.    if nofiles then exit;
  781.    i:=yiyiyi;
  782.    if i<1 then begin
  783.     i:=getfilenum ('get Info on');
  784.     if i=0 then exit;
  785.    end;
  786.    seekudfile (i);
  787.    read (udfile,ud);
  788.    okay:=checkok (ud);
  789.    if not okay then exit;
  790.    writehdr ('Extended File Information');
  791.     writeln (^R'    Filename: '^S,ud.filename);
  792.     writeln (^R'        Size: '^S,ud.filesize);
  793.     writeln (^R'      Points: '^S,ud.points);
  794.     writeln (^R'Program Name: '^S,ud.programname,' '+strr(ud.disknum)+^R'/'^S+strr(ud.totaldisk));
  795.     writeln (^R'   Times D/L: '^S,ud.downloaded);
  796.     writeln (^R' Unrated/New: '^S,yesno(ud.newfile));
  797.     writeln (^R' Special Ask: '^S,yesno(ud.specialfile));
  798.     writeln (^R'     Sent by: '^S,ud.sentby);
  799.     writeln (^R'     Sent on: '^S,datestr(ud.when));
  800.     writeln (^R'     Sent at: '^S,timestr(ud.when));
  801.     writeln (' Extended Desc: '^S);
  802.     a:=copy (ud.extdesc,1,80);
  803.     ansicolor (urec.statcolor);
  804.     writeln (a);
  805.     if length(ud.extdesc)>80 then begin
  806.      b:=copy (ud.extdesc,81,80);
  807.      ansicolor (urec.statcolor);
  808.      writeln (b);
  809.     end;
  810.     if length(ud.extdesc)>160 then begin
  811.      c:=copy (ud.extdesc,161,80);
  812.      ansicolor (urec.statcolor);
  813.      writeln (c);
  814.     end;
  815.   end;
  816.  
  817. begin
  818. end.
  819.